home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / tjgold.zip / INSTALL.003 / DEMDB10.PAS < prev    next >
Pascal/Delphi Source File  |  1995-05-29  |  4KB  |  144 lines
  1. {--------------------------------------------------------------------------}
  2. {                Product: TechnoJock's Turbo Toolkit GOLD                  }
  3. {                                                                          }
  4. {                     TTT GOLD - DEMO PROGRAM                        }
  5. {                                                                          }
  6. {                Copyright 1986-1995  TechnoJock Software, Inc.            }
  7. {                           All Rights Reserved                            }
  8. {                          Restricted by License                           }
  9. {--------------------------------------------------------------------------}
  10.  
  11. {Description: DEMDB10.PAS
  12.               A variation of DEMGRD1 which shows how to lock
  13.               columns when scrolling left and right.
  14. }
  15.  
  16. program DemDb10;
  17.  
  18. {$I GOLDFLAG.INC}
  19.  
  20. uses CRT, GoldAttr, GoldFast, GoldMisc, GoldLink, GoldTint, GoldDate,
  21.           GoldStr, GoldDb, GoldKey, GoldWin, GoldList, GoldGrid;
  22.  
  23. const FN: string[12] = 'DEMCUST.DBF';
  24.  
  25. var
  26.    SourceList: SingleLL;
  27.    GridLayout: ListCfg;
  28.    GridHeading: string;
  29.    TabStops: array[1..4] of integer;
  30.    Handle: integer;
  31.    RecLen: integer;
  32.  
  33. procedure ShutDown;
  34. {}
  35. begin
  36.    PromptOK(' ERROR! ','Not enough memory to run program!');
  37.    halt;
  38. end; { ShutDown }
  39.  
  40. procedure SetScreen;
  41. {}
  42. begin
  43.    Clear(whiteonblue,' ');
  44.    ClearLine(1,RedOnLightgray);
  45.    WriteCenter(1,UseTint,'TTTGOLD');
  46.    ClearLine(25,BlackOnLightgray);
  47.    WritePlain(8,25,'│');
  48. end; { SetScreen }
  49.  
  50. function FieldType(Field:integer): string;
  51. {}
  52. begin
  53.    case DbGetFldType(Field) of
  54.       'C': FieldType := 'Character    ';
  55.       'N': FieldType := 'Numeric      ';
  56.       'D': FieldType := 'Date         ';
  57.       'L': FieldType := 'Logical      ';
  58.       'M': FieldType := 'Memo         ';
  59.    end;
  60. end; {FieldType}
  61.  
  62. function FieldLength(FL:integer):string;
  63. {}
  64. var Len: integer;
  65. begin
  66.    Len := DbGetFldLength(FL);
  67.    FieldLength := PadLeft(IntToStr(Len),9,' ');
  68.    inc(RecLen,Len);
  69. end;
  70.  
  71. procedure FillTheList;
  72. {}
  73. var I,X: integer;
  74. begin
  75.    I := 0;
  76.    InitSLLStr(SourceList);
  77.    SLLSetActiveList(SourceList);
  78.    for X := 1 to DbTotalFields do
  79.       inc(I,SLLAddStr(PadLeft(DbGetFldName(X),12,' ')
  80.                      +FieldType(X)
  81.                      +FieldLength(X)
  82.                      +IntToStr(DbGetFldDec(X))));
  83.    if I <> 0 then
  84.       Shutdown;
  85.    Gridheading := 'Name|Type|Length|DecPl';
  86.    TabStops[1] := 1;
  87.    TabStops[2] := 13;
  88.    TabStops[3] := 24;
  89.    TabStops[4] := 33;
  90. end; {FillTheList}
  91.  
  92. begin
  93. {$IFOPT D+}
  94.    HeapRecord;
  95. {$ENDIF}
  96.    SetScreen;
  97.    PromptOK(' DEMDBSX ','Displays the structure of a database file');
  98.    Handle := DbOpenDataSet(FN);
  99.    if Handle > 0 then
  100.    begin
  101.       RecLen := 1; {accounts for the status byte}
  102.       FillTheList;
  103.       MouseShow(true);
  104.       InitListCfg(GridLayout);
  105.       ListAssignSLL(GridLayout,SourceList);
  106.       ListAssignHeader(GridLayout,1,GridHeading);
  107.       ListScrollHeader(GridLayout,true);
  108.       GridAssignTabs(GridLayout,@TabStops,4);
  109.       GridSetLocks(GridLayout,1,0);
  110.       GridLayout.Col[Listheaders] := 15;
  111.       with GridLayOut do
  112.       begin
  113.          WX1 := 17;
  114.          WY1 := 12;
  115.          WX2 := 64;
  116.          WY2 := 22;
  117.          WStyle := 6;
  118.          LeftGap := 1;
  119.          RightGap := 1;
  120.          TopGap := 1;
  121.       end;
  122.       UseCustomChars;
  123.       MouseShow(true);
  124.       CursorOff;
  125.       Box3D(13,3,68,10,BlackOnCyan,WhiteOnCyan,1);
  126.       WriteAT(26,5,BlackOnCyan,'File Name : '+FN);
  127.       WriteAT(26,6,BlackOnCyan,'Date last updated : '+JulToStr(DbGetUpDate,MMDDYY));
  128.       WriteAT(26,7,BlackOnCyan,'Number of records : '+IntToStr(DbGetNumRecs));
  129.       WriteAT(26,8,BlackOnCyan,'Record Length : '+IntToStr(DbGetRecLen));
  130.       RunGrid(GridLayout,' File Structure ');
  131.       CursorOn;
  132.       MouseShow(false);
  133.       SLLSetActiveList(SourceList);
  134.       SLLDestroy;
  135.       DbCloseDataBase(Handle);
  136.    end
  137.    else
  138.       PromptOK(' App Error ','Unable to load Structure');
  139.    clrscr;
  140. {$IFOPT D+}
  141.    HeapCheck;
  142. {$ENDIF}
  143. end.
  144.